Visual Basic Graphics Programming (2nd Edition)/Visual Basic Graphics Programming 2nd Edition.iso/OldSrc/CH4/SRC/ROTATEF.FRM

Visual Basic Form | 1997-01-03 | 14.9 KB | 469 lines

VERSION 4.00
Begin VB.Form RotateForm
   Caption         =   "Rotate"
   ClientHeight    =   4560
   ClientLeft      =   1080
   ClientTop       =   1290
   ClientWidth     =   7680
   Height          =   5250
   Left            =   1020
   LinkTopic       =   "Form1"
   ScaleHeight     =   304
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   512
   Top             =   660
   Width           =   7800
   Begin VB.CommandButton CmdRotate
      Caption         =   "Rotate"
      Default         =   -1  'True
      Enabled         =   0   'False
      Height          =   495
      Left            =   1080
      TabIndex        =   4
      Top             =   3720
      Width           =   855
   End
   Begin VB.TextBox AngleText
      Height          =   285
      Left            =   1680
      TabIndex        =   3
      Text            =   "0"
      Top             =   3120
      Width           =   615
   End
   Begin VB.PictureBox ToPict
      AutoRedraw      =   -1  'True
      BackColor       =   &H00C0C0C0&
      Height          =   4560
      Left            =   3120
      Picture         =   "ROTATEF.frx":0000
      ScaleHeight     =   300
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   300
      TabIndex        =   1
      Top             =   0
      Width           =   4560
   End
   Begin VB.PictureBox FromPict
      AutoRedraw      =   -1  'True
      BackColor       =   &H00C0C0C0&
      Height          =   3060
      Left            =   0
      Picture         =   "ROTATEF.frx":0446
      ScaleHeight     =   200
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   200
      TabIndex        =   0
      Top             =   0
      Width           =   3060
   End
   Begin VB.Label Label1
      Caption         =   "Angle (degrees)"
      Height          =   255
      Left            =   480
      TabIndex        =   2
      Top             =   3120
      Width           =   1215
   End
   Begin MSComDlg.CommonDialog FileDialog
      Left            =   2520
      Top             =   3120
      _Version        =   65536
      _ExtentX        =   847
      _ExtentY        =   847
      _StockProps     =   0
      CancelError     =   -1  'True
   End
   Begin VB.Menu mnuFile
      Caption         =   "&File"
      Begin VB.Menu mnuFileLoad
         Caption         =   "&Load..."
         Shortcut        =   ^L
      End
      Begin VB.Menu mnuFileSep
         Caption         =   "-"
      End
      Begin VB.Menu mnuFileExit
         Caption         =   "E&xit"
      End
   End
Attribute VB_Name = "RotateForm"
Attribute VB_Creatable = False
Attribute VB_Exposed = False
Option Explicit
Dim SysPalSize As Integer
Dim NumStaticColors As Integer
Dim StaticColor1 As Integer
Dim StaticColor2 As Integer
Dim LogPal As Integer
Dim palentry(0 To 255) As PALETTEENTRY
Dim wid As Long
Dim hgt As Long
Dim bytes() As Byte
' ************************************************
' Draw the rotated image.
' ************************************************
Sub DrawImage()
Const PI = 3.14159
Dim theta As Single
Dim fcx As Integer
Dim fcy As Integer
Dim tcx As Integer
Dim tcy As Integer
    If Not IsNumeric(AngleText.Text) Then _
        AngleText.Text = 0
    theta = PI * CSng(AngleText.Text) / 180#
    fcx = FromPict.ScaleWidth / 2
    fcy = FromPict.ScaleHeight / 2
    tcx = ToPict.ScaleWidth / 2
    tcy = ToPict.ScaleHeight / 2
    ToPict.Cls
    RotatePicture FromPict, ToPict, theta, _
        0, 0, _
        FromPict.ScaleWidth - 1, _
        FromPict.ScaleHeight - 1, _
        fcx, fcy, tcx, tcy
End Sub
' ************************************************
' Rotate the picture in from_pic and place it
' in to_pic. Rotate the area fx1 <= x <= fx2,
' fy1 <= y <= fy2 through angle theta radians
' around the point (cfx, cfy). Place the result so
' (cfx, cfy) maps to (ctx, cty).
' ************************************************
Sub RotatePicture( _
    ByVal from_pic As Control, ByVal to_pic As Control, _
    ByVal theta As Single, _
    ByVal fx1 As Integer, ByVal fy1 As Integer, _
    ByVal fx2 As Integer, ByVal fy2 As Integer, _
    ByVal cfx As Integer, ByVal cfy As Integer, _
    ByVal ctx As Integer, ByVal cty As Integer)
Dim bm As BITMAP
Dim hbm As Integer
Dim status As Long
Dim from_bytes() As Byte
Dim to_bytes() As Byte
Dim from_wid As Long
Dim from_hgt As Long
Dim to_wid As Long
Dim to_hgt As Long
Dim sin_theta As Single
Dim cos_theta As Single
Dim tx1 As Integer
Dim tx2 As Integer
Dim ty1 As Integer
Dim ty2 As Integer
Dim tx As Integer
Dim ty As Integer
Dim fx As Single
Dim fy As Single
Dim ifx As Integer
Dim ify As Integer
Dim dx As Single
Dim dy As Single
Dim c1 As Integer
Dim c2 As Integer
Dim c3 As Integer
Dim c4 As Integer
Dim i1 As Integer
Dim i2 As Integer
Dim clr As Integer
    ' Get from_pic's pixels.
    hbm = from_pic.Image
    status = GetObject(hbm, BITMAP_SIZE, bm)
    from_wid = bm.bmWidthBytes
    from_hgt = bm.bmHeight
    ReDim from_bytes(0 To from_wid - 1, 0 To from_hgt - 1)
    status = GetBitmapBits(hbm, from_wid * from_hgt, from_bytes(0, 0))
    ' Get to_pic's pixels.
    hbm = to_pic.Image
    status = GetObject(hbm, BITMAP_SIZE, bm)
    to_wid = bm.bmWidthBytes
    to_hgt = bm.bmHeight
    ReDim to_bytes(0 To to_wid - 1, 0 To to_hgt - 1)
    status = GetBitmapBits(hbm, to_wid * to_hgt, to_bytes(0, 0))
    ' Compute the sine and cosine of theta.
    sin_theta = Sin(theta)
    cos_theta = Cos(theta)

    ' Make some bounds for to_pic.
    tx1 = (fx1 - cfx) * cos_theta + (fy1 - cfy) * sin_theta + ctx
    ty1 = -(fx1 - cfx) * sin_theta + (fy1 - cfy) * cos_theta + cty
    tx2 = tx1
    ty2 = ty1
    tx = (fx1 - cfx) * cos_theta + (fy2 - cfy) * sin_theta + ctx
    ty = -(fx1 - cfx) * sin_theta + (fy2 - cfy) * cos_theta + cty
    If tx1 > tx Then tx1 = tx
    If ty1 > ty Then ty1 = ty
    If tx2 < tx Then tx2 = tx
    If ty2 < ty Then ty2 = ty
    tx = (fx2 - cfx) * cos_theta + (fy1 - cfy) * sin_theta + ctx
    ty = -(fx2 - cfx) * sin_theta + (fy1 - cfy) * cos_theta + cty
    If tx1 > tx Then tx1 = tx
    If ty1 > ty Then ty1 = ty
    If tx2 < tx Then tx2 = tx
    If ty2 < ty Then ty2 = ty
    tx = (fx2 - cfx) * cos_theta + (fy2 - cfy) * sin_theta + ctx
    ty = -(fx2 - cfx) * sin_theta + (fy2 - cfy) * cos_theta + cty
    If tx1 > tx Then tx1 = tx
    If ty1 > ty Then ty1 = ty
    If tx2 < tx Then tx2 = tx
    If ty2 < ty Then ty2 = ty
    If tx1 < 1 Then tx1 = 1
    If tx2 < 1 Then tx2 = 1
    If tx1 > to_wid - 1 Then tx1 = to_wid - 1
    If tx2 > to_wid - 1 Then tx2 = to_wid - 1
    If ty1 < 1 Then ty1 = 1
    If ty2 < 1 Then ty2 = 1
    If ty1 > to_hgt - 1 Then ty1 = to_hgt - 1
    If ty2 > to_hgt - 1 Then ty2 = to_hgt - 1
    ' Perform the rotation.
    For ty = ty1 To ty2
        For tx = tx1 To tx2
            ' Find the location (fx, fy) that maps
            ' to the pixel (tx, ty).
            fx = (tx - ctx) * cos_theta - (ty - cty) * sin_theta + cfx
            fy = (tx - ctx) * sin_theta + (ty - cty) * cos_theta + cfy
            ' Skip it if any of the four nearest
            ' source pixels lie outside the allowed
            ' source area.
            ify = Int(fy)
            ifx = Int(fx)
            If ifx >= fx1 And ifx < fx2 And _
               ify >= fy1 And ify < fy2 Then
                ' Interpolate using the four nearest
                ' pixels in from_pic.
                dy = fy - ify
                dx = fx - ifx
                c1 = palentry(from_bytes(ifx, ify)).peRed
                c2 = palentry(from_bytes(ifx + 1, ify)).peRed
                c3 = palentry(from_bytes(ifx, ify + 1)).peRed
                c4 = palentry(from_bytes(ifx + 1, ify + 1)).peRed
                ' Interpolate in the Y direction.
                i1 = c1 * (1 - dy) + c3 * dy
                i2 = c2 * (1 - dy) + c4 * dy
                ' Interpolate the results in the X direction.
                clr = i1 * (1 - dx) + i2 * dx
                to_bytes(tx, ty) = NearestNonstaticGray(clr)
            End If
        Next tx
    Next ty
    ' Update from_pic.
    status = SetBitmapBits(hbm, to_wid * to_hgt, to_bytes(0, 0))
    to_pic.Refresh
End Sub
' ***********************************************
' Load the control's palette so the non-static
' colors are grays. Map the logical palette to
' match the system palette. Convert the image to
' use the non-static grays.
' Set the following module global variables.
'   LogPal      Image logical palette handle.
'   palentry()  Image logical palette entries.
'   wid         Width of image.
'   hgt         Height of image.
'   bytes(1 To wid, 1 To hgt)
'               Image pixel values.
' ***********************************************
Sub MatchGrayPalette(pic As Control)
Dim sys(0 To 255) As PALETTEENTRY
Dim i As Integer
Dim bm As BITMAP
Dim hbm As Integer
Dim status As Long
Dim X As Integer
Dim Y As Integer
Dim gray As Single
Dim dgray As Single
Dim c As Integer
Dim clr As Integer
    ' Make sure pic has the foreground palette.
    pic.ZOrder
    i = RealizePalette(pic.hdc)
    DoEvents
    ' Get the system palette entries.
    i = GetSystemPaletteEntries(pic.hdc, 0, SysPalSize, sys(0))

    ' Get the image pixels.
    hbm = pic.Image
    status = GetObject(hbm, BITMAP_SIZE, bm)
    wid = bm.bmWidthBytes
    hgt = bm.bmHeight
    ReDim bytes(1 To wid, 1 To hgt)
    status = GetBitmapBits(hbm, wid * hgt, bytes(1, 1))
    ' Make the logical palette as big as possible.
    LogPal = pic.Picture.hPal
    If ResizePalette(LogPal, SysPalSize) = 0 Then
        Beep
        MsgBox "Error resizing logical palette.", _
            vbExclamation
        Exit Sub
    End If
    ' Blank the non-static colors.
    For i = 0 To StaticColor1
        palentry(i) = sys(i)
    Next i
    For i = StaticColor1 + 1 To StaticColor2 - 1
        With palentry(i)
            .peRed = 0
            .peGreen = 0
            .peBlue = 0
            .peFlags = PC_NOCOLLAPSE
        End With
    Next i
    For i = StaticColor2 To 255
        palentry(i) = sys(i)
    Next i
    i = SetPaletteEntries(LogPal, 0, SysPalSize, palentry(0))
    ' Insert the non-static grays.
    gray = 0
    dgray = 255 / (StaticColor2 - StaticColor1 - 2)
    For i = StaticColor1 + 1 To StaticColor2 - 1
        c = gray
        gray = gray + dgray
        With palentry(i)
            .peRed = c
            .peGreen = c
            .peBlue = c
        End With
    Next i
    i = SetPaletteEntries(LogPal, StaticColor1 + 1, StaticColor2 - StaticColor1 - 1, palentry(StaticColor1 + 1))
    ' Recreate the image using the new colors.
    For Y = 1 To hgt
        For X = 1 To wid
            clr = bytes(X, Y)
            With sys(clr)
                c = (CInt(.peRed) + .peGreen + .peBlue) / 3
            End With
            bytes(X, Y) = NearestNonstaticGray(c)
        Next X
    Next Y
    status = SetBitmapBits(hbm, wid * hgt, bytes(1, 1))
    ' Realize the gray palette.
    i = RealizePalette(pic.hdc)
    pic.Refresh
End Sub
' ************************************************
' Return the index of the nonstatic gray closest
' to the given value (assuming the non-static
' colors are a gray scale created by
' MatchGrayPalette).
' ************************************************
Function NearestNonstaticGray(c As Integer) As Integer
Dim dgray As Single
    If c < 0 Then
        c = 0
    ElseIf c > 255 Then
        c = 255
    End If
    dgray = 255 / (StaticColor2 - StaticColor1 - 2)
    NearestNonstaticGray = c / dgray + StaticColor1 + 1
End Function
' ************************************************
' Draw the rotated image.
' ************************************************
Private Sub CmdRotate_Click()
    WaitStart
    DrawImage
    WaitEnd
End Sub
Private Sub Form_Load()
Dim i As Integer
    ' Make sure the screen supports palettes.
    If Not GetDeviceCaps(hdc, RASTERCAPS) And RC_PALETTE Then
        Beep
        MsgBox "This monitor does not support palettes.", _
            vbCritical
        End
    End If
    ' Get system palette size and # static colors.
    SysPalSize = GetDeviceCaps(hdc, SIZEPALETTE)
    NumStaticColors = GetDeviceCaps(hdc, NUMRESERVED)
    StaticColor1 = NumStaticColors \ 2 - 1
    StaticColor2 = SysPalSize - NumStaticColors \ 2
    ' Make the pictures all use gray palettes.
    Me.Show
    DoEvents
    WaitStart
    MatchGrayPalette ToPict
    DoEvents
    ' Let each image repair its palette if needed.
    FromPict.ZOrder
    DoEvents
    ToPict.ZOrder
    DoEvents
    WaitEnd
End Sub
' ***********************************************
' Reset the cursors for the form and all the
' picture boxes.
' ***********************************************
Sub WaitEnd()
    MousePointer = vbDefault
    FromPict.MousePointer = vbDefault
    ToPict.MousePointer = vbDefault
End Sub
' ***********************************************
' Give the form and all the picture boxes an
' hourglass cursor.
' ***********************************************
Sub WaitStart()
    MousePointer = vbHourglass
    FromPict.MousePointer = vbHourglass
    ToPict.MousePointer = vbHourglass
    DoEvents
End Sub
Private Sub Form_Unload(Cancel As Integer)
    End
End Sub
Private Sub mnuFileExit_Click()
    Unload Me
End Sub
' ***********************************************
' Load a new image file.
' ***********************************************
Private Sub mnuFileLoad_Click()
Dim fname As String
    ' Allow the user to pick a file.
    On Error Resume Next
    FileDialog.filename = "*.BMP;*.ICO;*.RLE;*.WMF;*.DIB"
    FileDialog.Flags = cdlOFNFileMustExist + cdlOFNHideReadOnly
    FileDialog.ShowOpen
    If Err.Number = cdlCancel Then
        Exit Sub
    ElseIf Err.Number <> 0 Then
        Beep
        MsgBox "Error selecting file.", , vbExclamation
        Exit Sub
    End If
    On Error GoTo 0
    fname = Trim$(FileDialog.filename)
    FileDialog.InitDir = Left$(fname, Len(fname) _
        - Len(FileDialog.FileTitle) - 1)
    ' Load the picture.
    WaitStart
    LoadFromPict fname
    DrawImage
    WaitEnd
End Sub
' ***********************************************
' Load the indicated file and prepare to work
' with its palette.
' ***********************************************
Sub LoadFromPict(fname As String)
Dim status As Long
    On Error GoTo LoadFileError
    FromPict.Picture = LoadPicture(fname)
    On Error GoTo 0

    MatchGrayPalette FromPict
    Caption = "Rotate [" & fname & "]"
    CmdRotate.Enabled = True
    Exit Sub
LoadFileError:
    Beep
    MsgBox "Error loading file " & fname & "." & _
        vbCrLf & Error$
    Exit Sub
End Sub